home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / grobjs.lisp < prev    next >
Text File  |  1993-07-17  |  12KB  |  337 lines
  1. ;; -*- Mode:LISP; Package:BOXER; Base:10.;fonts:cptfont; -*-
  2. ;;
  3. ;; Copyright 1984 Massachusetts Institute of Technology
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15. ;;
  16. ;;                          +-Data--+
  17. ;; This file is part of the | BOXER | system
  18. ;;                          +-------+
  19. ;;
  20. ;; Graphics Object Definitions 
  21. ;; Coordinate Transformation and Drawing Utilities
  22. ;; Also mouse-sensitivity code.
  23.  
  24. ;;; Each slot in the turlte flavor holds a dotted pair consisting of  
  25. ;;; the value of the slot in lisp and the box which holds the value in Boxer
  26. ;;; All the turtle mutators keep these two things in synch.  The second half
  27. ;;; dotted pair is nil if the sprite is missing a box for that state variable.
  28.  
  29. (DEFFLAVOR TURTLE
  30.     ((X-POSITION '(0.))
  31.      (Y-POSITION '(0.))
  32.      (ASSOC-GRAPHICS-BOX NIL)
  33.      (SPRITE-BOX NIL)
  34.      (SHOWN-P '(T))
  35.      (PEN '(DOWN))
  36.      (HOME '((0 0 )))
  37.      (SUBSPRITES NIL)
  38.      (SUPERIOR-TURTLE NIL)
  39.      (HEADING (NCONS 0.))
  40.      (SHAPE (NCONS *TURTLE-SHAPE*))
  41.      (SIZE '(1.)))
  42.        ()
  43.   (:SETTABLE-INSTANCE-VARIABLES SPRITE-BOX SUPERIOR-TURTLE) 
  44.   (:GETTABLE-INSTANCE-VARIABLES ASSOC-GRAPHICS-BOX SPRITE-BOX SUBSPRITES)
  45.   :INITABLE-INSTANCE-VARIABLES)
  46.  
  47. (DEFMETHOD (TURTLE :DUMP-FORM) ()
  48.   (LIST 'TURTLE  :X-POSITION (NCONS (CAR X-POSITION)) :Y-POSITION (NCONS (CAR Y-POSITION))
  49.     :SHOWN-P (NCONS (CAR SHOWN-P)) :PEN (NCONS (CAR PEN)) :HOME (NCONS (CAR HOME))
  50.     :HEADING (NCONS (CAR HEADING)) :SHAPE (NCONS (CAR SHAPE)) :SIZE (NCONS (CAR SIZE))))
  51.  
  52. (DEFUN MAKE-TURTLE ()
  53.   (MAKE-INSTANCE 'TURTLE))
  54.  
  55. (DEFMETHOD (TURTLE :SET-SPRITE-BOX) (BOX)
  56.   (SETQ SPRITE-BOX BOX))
  57.  
  58. (DEFMETHOD (TURTLE :COPY) ()
  59.   (MAKE-INSTANCE 'TURTLE
  60.          ':X-POSITION (NCONS (CAR X-POSITION))
  61.          ':Y-POSITION (NCONS (CAR Y-POSITION))
  62.          ':HEADING (NCONS (CAR HEADING))
  63.          ':SHOWN-P (NCONS (CAR SHOWN-P))
  64.          ':PEN (NCONS (CAR PEN))
  65.          ':HOME (NCONS (CAR HOME))
  66.          ':SHAPE (NCONS (CAR SHAPE))
  67.          ':SIZE (NCONS (CAR SIZE))))
  68.  
  69. (DEFTYPE-CHECKING-MACROS TURTLE "A Turtle")
  70.  
  71. ;;; Some useful variables that various types of objects need
  72.  
  73. (DEFCONST *DEFAULT-GRAPHICS-OBJECT-HEIGHT* 10.0)
  74.  
  75. (DEFCONST *DEFAULT-GRAPHICS-OBJECT-WIDTH* 10.0)
  76.  
  77.  
  78. ;;; turtle shape
  79.  
  80. (DEFCONST *TURTLE-HEIGHT* 15.0)
  81.  
  82. (DEFCONST *TURTLE-HALF-BASE* 5.0)
  83.  
  84. (DEFCONST *TURTLE-SHAPE*
  85.       (LIST :UP 0 (* .333 *TURTLE-HEIGHT*) :DOWN
  86.         (- *TURTLE-HALF-BASE*) 0
  87.             *TURTLE-HALF-BASE* (- *TURTLE-HEIGHT*)
  88.         *TURTLE-HALF-BASE* *TURTLE-HEIGHT*
  89.         (- *TURTLE-HALF-BASE*) 0
  90.         :UP 0 (- (* .333 *TURTLE-HEIGHT*))))
  91.  
  92.  
  93. ;;; Adding and removing graphics-objects to/from GRAPHICS-BOXES
  94.  
  95. (DEFMETHOD (GRAPHICS-BOX :ADD-GRAPHICS-OBJECT) (NEW-OBJECT)
  96.   (TELL NEW-OBJECT :SET-ASSOC-GRAPHICS-BOX SELF)
  97.   (SETF (GRAPHICS-SHEET-OBJECT-LIST GRAPHICS-SHEET)
  98.     (PUSH NEW-OBJECT (GRAPHICS-SHEET-OBJECT-LIST GRAPHICS-SHEET))))
  99.  
  100. (DEFMETHOD (GRAPHICS-BOX :REMOVE-GRAPHICS-OBJECT) (OLD-OBJECT)
  101.   (WHEN (EQ (TELL OLD-OBJECT :ASSOC-GRAPHICS-BOX) SELF)
  102.     (TELL OLD-OBJECT :SET-ASSOC-GRAPHICS-BOX NIL)
  103.     (SETF (GRAPHICS-SHEET-OBJECT-LIST GRAPHICS-SHEET)
  104.       (DELQ OLD-OBJECT (GRAPHICS-SHEET-OBJECT-LIST GRAPHICS-SHEET)))))
  105.  
  106. (DEFMETHOD (GRAPHICS-DATA-BOX :ADD-GRAPHICS-OBJECT) (NEW-OBJECT)
  107.   (TELL NEW-OBJECT :SET-ASSOC-GRAPHICS-BOX SELF)
  108.   (SETF (GRAPHICS-SHEET-OBJECT-LIST GRAPHICS-SHEET)
  109.     (PUSH NEW-OBJECT (GRAPHICS-SHEET-OBJECT-LIST GRAPHICS-SHEET))))
  110.  
  111. (DEFMETHOD (GRAPHICS-DATA-BOX :REMOVE-GRAPHICS-OBJECT) (OLD-OBJECT)
  112.   (WHEN (EQ (TELL OLD-OBJECT :ASSOC-GRAPHICS-BOX) SELF)
  113.     (TELL OLD-OBJECT :SET-ASSOC-GRAPHICS-BOX NIL)
  114.     (SETF (GRAPHICS-SHEET-OBJECT-LIST GRAPHICS-SHEET)
  115.       (DELQ OLD-OBJECT (GRAPHICS-SHEET-OBJECT-LIST GRAPHICS-SHEET)))))
  116.  
  117.  
  118. ;;; Mouse Sensitivity
  119.  
  120. (DEFMETHOD (SPRITE-BLINKER :OFF) ()
  121.   (TELL SELF :SET-VISIBILITY NIL)
  122.   (SETQ SELECTED-SPRITE NIL))
  123.  
  124. ;;; reset the sprite blinker after every change
  125. (DEFMETHOD (GRAPHICS-BOX :AFTER :MODIFIED) (IGNORE)
  126.   (TELL *SPRITE-BLINKER* :OFF))
  127.  
  128. ;;; this does the highlighting 
  129. (DEFMETHOD (SCREEN-BOX :HIGHLIGHT-SPRITE-UNDER-MOUSE) (X Y)
  130.   (LET ((G-BOX (IF (GRAPHICS-BOX? ACTUAL-OBJ)
  131.            ACTUAL-OBJ
  132.            (TELL ACTUAL-OBJ :PORTS))))
  133.     (WITH-GRAPHICS-VARS-BOUND G-BOX
  134.       (WITH-TURTLE-SLATE-ORIGINS SELF
  135.     (LET ((USER-X (USER-COORDINATE-X (- X %ORIGIN-X-OFFSET)))
  136.           (USER-Y (USER-COORDINATE-Y (- Y %ORIGIN-Y-OFFSET 1))))
  137.       (LET ((SPRITE (FIND-SPRITE-UNDER-POINT
  138.               USER-X USER-Y
  139.               (GRAPHICS-SHEET-OBJECT-LIST GR-SHEET))))
  140.         (IF (NULL SPRITE)
  141.         (TELL *SPRITE-BLINKER* :OFF)
  142.         (TELL *SPRITE-BLINKER* :HIGHLIGHT-SPRITE SPRITE SELF))))))))
  143.  
  144. (DEFVAR *MOUSING-ALLOWABLE-ERROR* 5 "Allowed error when pointing to a sprite with the mouse")
  145.  
  146. (DEFUN FIND-SPRITE-UNDER-POINT (USER-X USER-Y OBJECT-LIST
  147.                 &AUX SPRITE (SPRITE-AREA 999999)
  148.                 LEFT TOP RIGHT BOTTOM OBJECT-AREA OBJECT)
  149.    (TAGBODY
  150.     LOOP
  151.     (SETQ OBJECT (CAR OBJECT-LIST))
  152.     (SETQ OBJECT-LIST (CDR OBJECT-LIST))
  153.     (WHEN (AND (TURTLE? OBJECT) (TELL OBJECT :ABSOLUTE-SHOWN-P))
  154.       (MULTIPLE-VALUE (LEFT TOP RIGHT BOTTOM)
  155.     (TELL OBJECT :ENCLOSING-RECTANGLE))
  156.       (SETQ OBJECT-AREA (ABS (* (- LEFT RIGHT) (- TOP BOTTOM))))
  157.       (WHEN (AND (< OBJECT-AREA SPRITE-AREA)
  158.          (INCLUSIVE-BETWEEN? USER-X
  159.                      LEFT 
  160.                      (+ RIGHT *MOUSING-ALLOWABLE-ERROR*))
  161.          (INCLUSIVE-BETWEEN? USER-Y
  162.                      (- BOTTOM *MOUSING-ALLOWABLE-ERROR*)
  163.                      TOP)
  164.          (SETQ SPRITE-AREA OBJECT-AREA SPRITE OBJECT)))
  165.       (SETQ OBJECT-LIST (APPEND OBJECT-LIST (TELL OBJECT :SUBSPRITES))))
  166.       (WHEN OBJECT-LIST (GO LOOP)))
  167.   SPRITE)
  168.  
  169. ;;; call this method only within WITH-TURTLE-SLATE-ORIGINS.
  170.  
  171. (DEFMETHOD (SPRITE-BLINKER :HIGHLIGHT-SPRITE) (SPRITE SCREEN-BOX)
  172.   (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
  173.       (TELL SPRITE :ENCLOSING-RECTANGLE)
  174.     (LET ((ARRAY-LEFT (MAX (FIX-ARRAY-COORDINATE-X LEFT) -1.))
  175.       (ARRAY-TOP (MAX (FIX-ARRAY-COORDINATE-Y TOP) -1.))
  176.       (ARRAY-RIGHT (MIN (FIX-ARRAY-COORDINATE-X RIGHT) (1+ %DRAWING-WIDTH)))
  177.       (ARRAY-BOTTOM (MIN (FIX-ARRAY-COORDINATE-Y BOTTOM) (1+ %DRAWING-HEIGHT))))
  178.       (LET ((X (+ -2. %ORIGIN-X-OFFSET ARRAY-LEFT))
  179.         (Y (+ -2.  %ORIGIN-Y-OFFSET ARRAY-TOP))
  180.         (WIDTH (- ARRAY-RIGHT ARRAY-LEFT -2.))
  181.         (HEIGHT (- ARRAY-BOTTOM ARRAY-TOP -2.)))
  182.     (TELL SELF :SET-CURSORPOS X Y )
  183.     (TELL SELF :SET-SIZE WIDTH HEIGHT)
  184.     (TELL SELF :SET-VISIBILITY T))))
  185.   (SETQ SELECTED-SPRITE SPRITE)
  186.   (SETQ SPRITE-SCREEN-BOX SCREEN-BOX))
  187.  
  188.   
  189. ;;; coordinate transformations.
  190. ;;;
  191. ;;; ARRAY coordinates are referenced to the indices of the bit-array of the graphics box
  192. ;;; therefore in ARRAY coordinates, (0, 0) is in the upper-left hand corner whereas...
  193. ;;; ...in USER coordinates, which refer to the coordinates in which the user talks to the
  194. ;;; object, (0, 0) will be more or less in the middle of the box.
  195. ;;;
  196.   
  197. ;;; USER  ARRAY
  198.   
  199. (DEFUN FIX-ARRAY-COORDINATE-X (USER-X)
  200.   (FIXR (ARRAY-COORDINATE-X USER-X)))
  201.  
  202. (DEFUN ARRAY-COORDINATE-X (USER-X)
  203.   (+ (// %DRAWING-WIDTH 2) USER-X))
  204.  
  205. (DEFUN FIX-ARRAY-COORDINATE-Y (USER-Y)
  206.   (FIXR (ARRAY-COORDINATE-Y USER-Y)))
  207.  
  208. (DEFUN ARRAY-COORDINATE-Y (USER-Y)
  209.   (- (// %DRAWING-HEIGHT 2) (* USER-Y *SCRUNCH-FACTOR*)))
  210.  
  211. ;;; ARRAY  USER
  212.  
  213. (DEFUN USER-COORDINATE-X (ARRAY-X)
  214.   (- ARRAY-X (// %DRAWING-WIDTH 2)))
  215.  
  216. (DEFUN USER-COORDINATE-Y (ARRAY-Y)
  217.   (// (- (// %DRAWING-HEIGHT 2) ARRAY-Y) *SCRUNCH-FACTOR*))
  218.  
  219. ;;; these want ARRAY coordinates
  220.  
  221. (DEFUN POINT-IN-ARRAY? (X Y)
  222.   (AND (X-IN-ARRAY? X)
  223.        (Y-IN-ARRAY? Y)))
  224.  
  225. (DEFUN X-IN-ARRAY? (X)
  226.   (AND ( X 0) (< X %DRAWING-WIDTH)))
  227.  
  228. (DEFUN Y-IN-ARRAY? (Y)
  229.   (AND ( Y 0) (< Y %DRAWING-HEIGHT)))
  230.  
  231.  
  232.  
  233. ;;; normalize coordinates to the on screen position
  234.   
  235. (DEFUN WRAP-OBJECT-COORDS (OBJECT)
  236.   (TELL OBJECT :SET-X-POSITION (WRAP-X-COORDINATE (TELL OBJECT :X-POSITION)))
  237.   (TELL OBJECT :SET-Y-POSITION (WRAP-Y-COORDINATE (TELL OBJECT :Y-POSITION))))
  238.  
  239. (DEFUN WRAP-X-COORDINATE (USER-X)
  240.   (USER-COORDINATE-X (FLOAT-MODULO (ARRAY-COORDINATE-X USER-X) %DRAWING-WIDTH)))
  241.  
  242. (DEFUN WRAP-Y-COORDINATE (USER-Y)
  243.   (USER-COORDINATE-Y (FLOAT-MODULO (ARRAY-COORDINATE-Y USER-Y) %DRAWING-HEIGHT)))
  244.  
  245. (DEFUN FLOAT-MODULO (NUM MOD)
  246.   (LET ((X (- NUM (* (FIX (// NUM MOD)) MOD))))
  247.     (IF (MINUSP X) (+ X MOD) X)))
  248.  
  249. ;;;  ******************************************************************
  250. ;;;  Everything after this line has been made obsolete by sprite boxes.
  251. ;;;  and is only here for reference.  
  252. ;;;  ******************************************************************
  253.  
  254. ;;; Here is the basic flavor
  255. ;;; This defines a graphics object by its location only.  Anything built out of this should
  256. ;;; define its own methods for saving (in files) and displaying
  257. ;(DEFFLAVOR MINIMUM-GRAPHICS-OBJECT
  258. ;    ((X-POSITION 0.)
  259. ;     (Y-POSITION 0.)
  260. ;     (assoc-graphics-box NIL))
  261. ;    ()
  262. ;  :GETTABLE-INSTANCE-VARIABLES
  263. ;  :SETTABLE-INSTANCE-VARIABLES
  264. ;  :INITABLE-INSTANCE-VARIABLES
  265. ;  (:REQUIRED-METHODS :DRAW :ERASE)
  266. ;  (:DOCUMENTATION :ESSENTIAL-MIXIN
  267. ;   "All other graphics objects are built on top of this flavor. "))
  268.  
  269. (DEFTYPE-CHECKING-MACROS GRAPHICS-OBJECT "A graphics object")
  270.  
  271. ;;; some useful MIXINS
  272. ;(DEFFLAVOR EXPORTING-NAME-MIXIN
  273. ;    ((NAME NIL))
  274. ;    ()
  275. ;  :GETTABLE-INSTANCE-VARIABLES
  276. ;  :INITABLE-INSTANCE-VARIABLES
  277. ;  (:REQUIRED-FLAVORS MINIMUM-GRAPHICS-OBJECT)
  278. ;  (:DOCUMENTATION :MIXIN
  279. ;   "Gives the object a name so it can be accessed from outside of the Graphics Box. "))
  280.  
  281. ;;; BASIC methods that EVERY ONE uses
  282. ;;; higher level object generally should define their own main method for the following
  283. ;;; made obsolete by sprite boxes
  284. ;(DEFMETHOD (MINIMUM-GRAPHICS-OBJECT :GRAPHICS-BOX) ()
  285. ;  (GRAPHICS-SHEET-SUPERIOR-BOX ASSOCIATED-SHEET))
  286. ;
  287. ;(DEFMETHOD (MINIMUM-GRAPHICS-OBJECT :BEFORE :SET-ASSOCIATED-SHEET) (NEW-SHEET)
  288. ;  (WHEN (AND (NEQ NEW-SHEET ASSOCIATED-SHEET) (NOT-NULL ASSOCIATED-SHEET))
  289. ;    (TELL SELF :ERASE)))
  290. ;
  291. ;(DEFMETHOD (MINIMUM-GRAPHICS-OBJECT :AFTER :SET-ASSOCIATED-SHEET) (NEW-SHEET)
  292. ;  (WHEN (NOT-NULL NEW-SHEET)
  293. ;    (TELL SELF :DRAW)))
  294. ;
  295. ;(DEFMETHOD (MINIMUM-GRAPHICS-OBJECT :DESCRIPTION-LIST) ()
  296. ;  "This method should return a list of lists suitable for MAKE-BOX"
  297. ;  (LIST (NCONS (FORMAT NIL "I am a ~A" (TYPEP SELF)))
  298. ;    (NCONS (FORMAT NIL "X-position ~D" X-POSITION))
  299. ;    (NCONS (FORMAT NIL "Y-Position ~D" Y-POSITION))))
  300. ;
  301. ;(DEFMETHOD (MINIMUM-GRAPHICS-OBJECT :DRAW) ()
  302. ;  "This draw method assumes that position (0, 0) is in the upper left hand corner.
  303. ;Higher level draw methods which want (0, 0) to be elsewhere (like the
  304. ;  middle) should
  305. ;convert x and y positions before calling DRAW-LINE. "
  306. ;  (WITH-GRAPHICS-VARS-BOUND (GRAPHICS-SHEET-SUPERIOR-BOX ASSOCIATED-SHEET)
  307. ;    (CK-MODE-DRAW-LINE X-POSITION Y-POSITION (+ X-POSITION *DEFAULT-GRAPHICS-OBJECT-WIDTH*)
  308. ;            (+ Y-POSITION *DEFAULT-GRAPHICS-OBJECT-HEIGHT*))
  309. ;    (CK-Mode-DRAW-LINE (+ X-POSITION *DEFAULT-GRAPHICS-OBJECT-WIDTH*) Y-POSITION
  310. ;            X-POSITION (+ Y-POSITION *DEFAULT-GRAPHICS-OBJECT-HEIGHT*))))
  311. ;
  312. ;(DEFMETHOD (MINIMUM-GRAPHICS-OBJECT :ERASE) ()
  313. ;  (TELL SELF :DRAW))
  314. ;
  315.  
  316.  
  317.  
  318. ;;; Methods for MIXINs
  319. ;;; a crock so that TELL will work
  320. ;(DEFMETHOD (EXPORTING-NAME-MIXIN :LOOKUP-STATIC-VARIABLE-CHECK-SUPERIORS) (VAR)
  321. ;  (TELL-CHECK-NIL (GRAPHICS-SHEET-SUPERIOR-BOX ASSOCIATED-SHEET)
  322. ;           :LOOKUP-STATIC-VARIABLE-CHECK-SUPERIORS VAR))
  323. ;
  324. ;(DEFMETHOD (EXPORTING-NAME-MIXIN :BEFORE :SET-ASSOCIATED-SHEET) (NEW-SHEET)
  325. ;  (COND ((AND (NULL NEW-SHEET) (NOT-NULL ASSOCIATED-SHEET))
  326. ;     (TELL (GRAPHICS-SHEET-SUPERIOR-BOX ASSOCIATED-SHEET)
  327. ;           :REMOVE-ALL-STATIC-BINDINGS SELF))
  328. ;    ((AND (NEQ NEW-SHEET ASSOCIATED-SHEET)(NOT-NULL NEW-SHEET)(NOT-NULL ASSOCIATED-SHEET))
  329. ;     (LET ((SURROUNDING-BOX (GRAPHICS-SHEET-SUPERIOR-BOX NEW-SHEET)))
  330. ;       (TELL (GRAPHICS-SHEET-SUPERIOR-BOX ASSOCIATED-SHEET)
  331. ;         :REMOVE-ALL-STATIC-BINDINGS SELF)
  332. ;       (WHEN (AND NAME (SYMBOLP NAME))
  333. ;         (TELL SURROUNDING-BOX :ADD-STATIC-VARIABLE-PAIR NAME SELF)
  334. ;         (TELL SURROUNDING-BOX :EXPORT-VARIABLE NAME))))))
  335. ;
  336.  
  337.